home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / Examples / faster-make-instance-patch.lisp < prev    next >
Encoding:
Text File  |  1993-03-15  |  6.7 KB  |  192 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;; faster-make-instance-patch.lisp
  4. ;;copyright © 1992, 1993, Apple Computer, Inc.
  5. ;;
  6. ;;
  7. ;;   Speed up make-instance by 228 microseconds (on a ci)
  8.  
  9. ; (require-type class 'std-class) used to call find-class
  10. ; Speed up (make-instance 'class-name ...) by an additional
  11. ; 240 microseconds by doing the gethash at load time.
  12.  
  13. ; Files compiled after this patch has been loaded
  14. ; will fail to load in versions of MCL 2.0 that do not 
  15. ; include it; attempting this will cause "Error: 
  16. ; Undefined function CCL::FIND-CLASS-CELL." If you produce 
  17. ; software that may be loaded into an MCL 2.0 without this 
  18. ; patch, you may wish to include this source with your code.
  19.  
  20.  
  21. (in-package :ccl)
  22.  
  23. (eval-when (:compile-toplevel :execute)
  24.   (require :lapmacros))
  25.  
  26. (let ((*warn-if-redefine* nil)
  27.       (*warn-if-redefine-kernel* nil))
  28.  
  29. (eval-when (:compile-toplevel :execute :load-toplevel)
  30.   (set-type-predicate 'std-class 'std-class-p))
  31.  
  32. (defun default-initargs (class initargs)
  33.   (unless (std-class-p class)
  34.     (setq class (require-type class 'std-class)))
  35.   (when (null (%class-cpl class)) (initialize-class class))
  36.   (let ((defaults ()))
  37.     (dolist (key.form (%class-default-initargs class))
  38.       (unless (pl-search initargs (%car key.form))
  39.         (setq defaults
  40.               (list* (if (listp (%cdr key.form))
  41.                        (%cadr key.form)
  42.                        (funcall (%cdr key.form)))
  43.                      (%car key.form)
  44.                      defaults))))
  45.     (when defaults
  46.       (setq initargs (append initargs (nreverse defaults))))
  47.     initargs))
  48.  
  49. (defun find-class-cell (name create?)
  50.   (let ((cell (gethash name %find-classes%)))
  51.     (or cell
  52.         (and create?
  53.              (setf (gethash name %find-classes%) (cons name nil))))))
  54.  
  55. (without-interrupts
  56.  (defun find-class (name &optional (errorp t) environment)
  57.           (let* ((cell (find-class-cell name nil)))
  58.             (declare (list cell))
  59.             (or (cdr cell)
  60.                 (let ((defenv (and environment (definition-environment environment))))
  61.                   (when defenv
  62.                     (dolist (class (defenv.classes defenv))
  63.                       (when (eq name (%class-name class))
  64.                         (return class)))))
  65.                 (when (or errorp (not (symbolp name)))
  66.                   (error "Class named ~S not found." name)))))
  67.  
  68. ; Update %find-classes% to the new order
  69.  (maphash #'(lambda (name class)
  70.               (unless (listp class)
  71.                 (setf (gethash name %find-classes%) (cons name class))))
  72.           %find-classes%)
  73.  
  74. (defun set-find-class (name class)
  75.   (setq name (require-type name 'symbol))
  76.   (let ((cell (find-class-cell name class)))
  77.     (declare (type list cell))
  78.     (when *warn-if-redefine-kernel*
  79.       (let ((old-class (cdr cell)))
  80.         (when (and old-class (neq class old-class) (%class-kernel-p old-class))
  81.           (cerror "Redefine ~S."
  82.                   "~S is already defined in the CCL kernel." old-class)
  83.           (setf (%class-kernel-p old-class) nil))))
  84.     (when (null class)
  85.       (when cell
  86.         (setf (cdr cell) nil))
  87.       (return-from set-find-class nil))
  88.     (setq class (require-type class 'class))
  89.     (when (built-in-type-p name)
  90.       (unless (eq (cdr cell) class)
  91.         (error "Cannot redefine built-in type name ~S" name)))
  92.     (when (%deftype-expander name)
  93.       (cerror "set ~S anyway, removing the ~*~S definition"
  94.               "Cannot set ~S because type ~S is already defined by ~S"
  95.               `(find-class ',name) name 'deftype)
  96.       (%deftype name nil nil))
  97.     (setf (cdr cell) class)))
  98.  
  99. ) ; end of without-interrupts
  100.  
  101. (defun map-classes (function)
  102.   (with-hash-table-iterator (m %find-classes%)
  103.     (loop
  104.       (multiple-value-bind (found name cell) (m)
  105.         (declare (list cell))
  106.         (unless found (return))
  107.         (when (cdr cell)
  108.           (funcall function name (cdr cell)))))))
  109.  
  110. (defun clear-specializer-direct-methods-caches ()
  111.   (setq *maintain-class-direct-methods* nil)
  112.   (map-classes #'(lambda (name class)
  113.                    (declare (ignore name))
  114.                    (when (typep class 'class)
  115.                      (setf (%class-direct-methods class) nil)))))
  116.  
  117. (defun clear-valid-initargs-caches ()
  118.   (map-classes #'(lambda (name class)
  119.                    (declare (ignore name))
  120.                    (when (std-class-p class)
  121.                      (setf (%class-make-instance-initargs class) nil
  122.                            (%class-reinit-initargs class) nil
  123.                            (%class-redefined-initargs class) nil
  124.                            (%class-changed-initargs class) nil
  125.                            (%class-aux-init-functions-cache class) nil)))))
  126.  
  127. #|
  128. (defun %make-instance (class-cell &rest initargs)
  129.   (declare (dynamic-extent initargs))
  130.   (apply #'make-instance
  131.          (or (cdr class-cell) (car (the list class-cell)))
  132.          initargs))
  133. |#
  134.  
  135. ; This saves 29 microseconds on a ci.
  136. ; I really wish the compiler would special case rest args
  137. ; that are used only as the last argument to apply.
  138. (defun %make-instance (&lap class-cell &rest initargs)
  139.   (lap
  140.     (if# (eq (cmp.w ($ 8) nargs))
  141.       ; 2 args. class-cell is in arg_y
  142.       (move.l arg_y atemp0)
  143.       (bif (eq (dtagp arg_y $t_cons)) @bad)
  144.       (move.l (cdr atemp0) arg_y)
  145.       (bif (ne (cmp.l nilreg arg_y)) @doit)
  146.       (move.l (car atemp0) arg_y)
  147.     elseif# mi
  148.      (if# (eq (tst.w nargs))
  149.        ; no args, generate error
  150.        (jsr_subprim $sp-n-req-rest)
  151.        (dc.w 4)
  152.        (dc.w #_debugger))
  153.      ; 1 arg. class-cell is in arg_z
  154.       (move.l arg_z atemp0)
  155.       (bif (eq (dtagp arg_z $t_cons)) @bad)
  156.       (move.l (cdr atemp0) arg_z)
  157.       (bif (ne (cmp.l nilreg arg_z)) @doit)
  158.       (move.l (car atemp0) arg_z)
  159.     elseif# (eq (cmp.w ($ 12) nargs))
  160.      ; 3 args. class-cell is in arg_x
  161.      (move.l arg_x atemp0)
  162.      (bif (eq (dtagp arg_x $t_cons)) @bad)
  163.      (move.l (cdr atemp0) arg_x)
  164.      (bif (ne (cmp.l nilreg arg_x)) @doit)
  165.      (move.l (car atemp0) arg_x)
  166.     else#
  167.      ; > 3 args. class-cell is on the stack
  168.      (lea (vsp nargs -16) atemp1)
  169.      (move.l @atemp1 da)
  170.      (move.l da atemp0)
  171.      (bif (eq (dtagp da $t_cons)) @bad)
  172.      (move.l (cdr atemp0) da)
  173.      (if# (ne (cmp.l nilreg da))
  174.        (move.l da @atemp1)
  175.        (bra @doit))
  176.      (move.l (car atemp0) @atemp1))
  177.     @doit
  178.     (jmp #'make-instance)
  179.     @bad
  180.      (vpush_argregs_nz)
  181.      (pea (vsp nargs))
  182.      (wtaerr atemp0 'list)))
  183.  
  184. (define-compiler-macro make-instance (&whole call class &rest initargs)
  185.   (if (and (listp class)
  186.            (eq (car class) 'quote)
  187.            (symbolp (cadr class))
  188.            (null (cddr class)))
  189.     `(%make-instance (load-time-value (find-class-cell ,class t))
  190.                      ,@initargs)
  191.     call))
  192. )